perm filename FILL11.F4[P11,LCS] blob
sn#595814 filedate 1981-06-18 generic text, type T, neo UTF8
C****** CHANGE 3, 4 AND 5 TO JFCL IN DDT WHEN USING DISTORTION.(SEE 'LINES')
SUBROUTINE FILLMS(L,IDAT,R2,CENTR,R6,R7)
DIMENSION IDAT(1)
COMMON/DST/BB,CC/FLM/X(400) /ALF/INP,H(35) /RINC/RINC
C ????? HOW BIG MUST X ARRAY BE. 350 IS CURRENT LIMIT IN 'CLEFS'
C X ARRAY CAN PROBABLY BE SHARED WITH SOME OTHER ARRAY.
C H ARRAY HOLDS NUMBER OF VERTICAL SLICES NEEDED AT ANY ONE TIME.
C IDAT IS THE PACKED ARRAY OF POINTS FROM THE 'DRW' PROGRAM.
COMMON/PLTR/IPLT,RHT,DIS /LL/LL /STF/RG(8),RSTJ2
DATA M2/2/
DX=DIS
RX=RHT
D=RSTJ2*R6
22 R=RSTJ2*R7
CC GO TO 1
CC C=CC
CC B=BB
CCC SAVES IT. IT WILL RETURN LATER.
CC BB=B/DIS
CC CC=1000
11 KK=-2
DO 205 J=1,L
KK=KK+3
CALL UNPACK(M,N,IDAT(J))
X(KK)=(R2+D*M)*DIS
X(KK+1)=(CENTR+R*N)*RHT
33 X(KK+2)=LL
CC GO TO 205
CC X(KK+1)=X(KK+1)*(C-BB*(ABS(X(KK))))
C FOR DISTORTION
205 CONTINUE
KNT=KK+2
DIS=1.0
RHT=DIS
C THESE MUST BE 1.0 IN 'LINES' WHEN FILLING.
RL=X(1)
RR=RL
DO 1 K=1,KNT,3
IF(X(K+2).EQ.3.)X(K+2)=-1.
A=X(K)
IF(X(K+3).EQ.A)X(K+5)=-1.
C VERTICAL LINES WILL BE IGNORED.
IF(A.LT.RL)RL=A
1 IF(A.GT.RR)RR=A
C GET LEFT AND RIGHT EXTREME LIMITS.
RL=RL-.5
2 RL=RL+RINC
C SLICE COUNTER
IF(RL.GE.RR)GO TO 66
M=0
DO 3 J=4,KNT,3
IF(X(J+2).LT.0)GO TO 3
A=X(J)
B=X(J-3)
IF(A.LT.B)GO TO 30
C EXCHANGE A,B
C=B
B=A
A=C
30 IF(A.GE.RL)GO TO 3
IF(B.LT.RL)GO TO 3
C SKIP IF THIS SLICE IS OUT OF BOUNDS
M=M+1
C=X(J-2)
C THESE ARE Y COORDS.
B=X(J)-X(J-3)
CC IF(B.NE.0)GO TO 34
CC H(M)=C
CC GO TO 3
C GET STARTING POS. OF SLICE
34 A=(X(J+1)-C)*(RL-X(J-3))
H(M)=A/B+C
C H ARRAY CONTAINS ALL SLICES IN THIS HORIZ. POS.
3 CONTINUE
IF(M.EQ.0)GO TO 2
C M=0=SPACE BETWEEN OBJECTS -- NO FILLER
J=1
5 IF(H(J).GE.H(J+1))GO TO 4
C SORTS HEIGHTS
A=H(J)
C EXCHANGE H(J),H(J+1)
H(J)=H(J+1)
H(J+1)=A
IF(J.EQ.1)GO TO 4
J=J-1
GO TO 5
4 J=J+1
IF(J.LT.M)GO TO 5
C GO BACK IF MORE SORTING TO BE DONE
NN=1
6 A=H(NN)
B=H(NN+1)
IF(A-B.LE.1.0)GO TO 7
CALL LINES(RL,A,3)
CALL LINES(RL,B,2)
7 NN=NN+2
C SKIP BY 2'S
IF(NN.LT.M)GO TO 6
GO TO 2
66 DIS=DX
RHT=RX
C RESTORE PROPER SIZE FACTORS.
END
CC DIST4: JRA 16,6(16) ;5 RETURN
CC MOVE B ;C NEXT TO RESET DISTORTION FACT.
CC MOVEM DST ; BB=B
CC MOVE C ; CC=C
CC MOVEM DST+1
CC JRA 16,6(16) ; RETURN
CC END